home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / scm / jackal1a.lha / jacal / unparse.scm < prev    next >
Encoding:
Text File  |  1992-12-23  |  12.5 KB  |  402 lines
  1. ;;; JACAL: Symbolic Mathematics System.        -*-scheme-*-
  2. ;;; Copyright 1992 Aubrey Jaffer.
  3. ;;; See the file "COPYING" for terms applying to this program.
  4.  
  5. ;;; a LINE is a list of column positions and strings or characters
  6. ;;; which appear there on one horizontal line.
  7.  
  8. ;;; a BOX is a list of pairs of line-numbers and LINEs.
  9. ;;; a PBOX consists of a BP (binding power) and a list of boxes.
  10.  
  11. ;;; a TEMPLATE is an HBOX.  An HBOX is a list of strings, symbols and
  12. ;;; VBOXes.  A VBOX is a list of pairs of a row position and an HBOX
  13. ;;; or a list of a character.
  14.  
  15. ;;; A number of the form #dNBBB in a template is replaced with the BOX
  16. ;;; for argument N.  If the #dNBBB appears in a HBOX then it is glued
  17. ;;; horizontally to the other elements in the HBOX.  If the #dNBBB
  18. ;;; appears in a VBOX then it is glued vertically to the other
  19. ;;; elements in the VBOX.  BBB denotes the maximum binding power of
  20. ;;; the argument.  If the binding power of the argument is less than
  21. ;;; BBB, parenthesis will be added according to TEMPLATE:PARENTHESIS.
  22.  
  23. ;;; Characters in HBOXes are expanded horizontally to fill any empty
  24. ;;; space in their line.  A list of a character VBOX is expanded
  25. ;;; vertically to fill any empty space in its containing HBOX.
  26.  
  27. ;;; The symbol 'BREAK will break the line if there is not enough
  28. ;;; horizontal room remaining.
  29.  
  30. (require 'rev3-procedures)
  31. (require 'common-list-functions)
  32.  
  33. ;;; TEXT-WIDTH
  34.  
  35. (define text-width string-length)
  36.  
  37. ;;; return the position of symbol #dNBBB
  38.  
  39. (define (arg-pos num)
  40.   (quotient num 1000))
  41.  
  42. (define (arg-bp num)
  43.   (modulo num 1000))
  44.  
  45. (define make-template cons)
  46. (define template-bp car)
  47. (define template-hbox cdr)
  48.  
  49. ;;; Utility routines for dealing with BOX
  50. ;;; BOX is a list of (line-number-referred-to-center . LINE)
  51. ;;; LINE is a list of POSITIONs and STRINGs.
  52. ;(require 'record)
  53. ;(define pbox-type (make-record-type "box" '(bp lines)))
  54. ;(define make-pbox (record-constructor pbox-type))
  55. ;(define pbox-bp (record-accessor pbox-type 'bp))
  56. ;(define pbox-lines (record-accessor pbox-type 'lines))
  57.  
  58. (define make-pbox cons)
  59. (define pbox-bp car)
  60. (define pbox-lines cdr)
  61.  
  62. (define top-edge caar)
  63.  
  64. (define left-edge cadar)
  65.  
  66. (define (bottom-edge box)
  67.   (caar (last-pair box)))
  68.  
  69. (define (right-edge box)
  70.   (define redge 0)
  71.   (for-each
  72.    (lambda (line)
  73. ;;;     (define re 0)
  74. ;;;     (for-each (lambda (x)
  75. ;;;         (cond ((number? x) (set! re x))
  76. ;;;               ((string? x)
  77. ;;;            (set! re (+ (text-width x) re)))))
  78. ;;;           (cdr line))
  79. ;;;     (set! redge (max re redge))
  80.      (if (not (null? (cdr line)))
  81.      (let ((end (last line 2)))
  82.        (set! redge (max redge (+ (car end)
  83.                      (if (string? (cadr end))
  84.                      (text-width (cadr end))
  85.                      0)))))))
  86.    box)
  87.   redge)
  88.  
  89. (define (shift-numbers! lst inc)
  90.   (cond ((null? lst))
  91.     (else (set-car! lst (+ inc (car lst)))
  92.           (shift-numbers! (cddr lst) inc))))
  93.  
  94. ;;; routines for actually writing the 2d formated output to a port.
  95. ;;; These can be replaced with code which does cursor positioning.
  96.  
  97. (define (display-box linum box)
  98.   (cond ((null? box) (+ 1 linum))
  99.     ((>= linum (top-edge box))
  100.      (display-line 0 #\  (cdar box))
  101.      (if (> linum (top-edge box))
  102.          (display "DISPLAY-BOX: out of sequence"))
  103.      (newline)
  104.      (display-box (+ 1 linum) (cdr box)))
  105.     (else
  106.      (newline)
  107.      (display-box (+ 1 linum) box))))
  108.  
  109. (define (display-line hpos fillchr line)
  110.   (cond ((null? line) hpos)
  111.     ((string? (cadr line))
  112.      (display (make-string (- (car line) hpos) fillchr))
  113.      (display (cadr line))
  114.      (display-line (+ (car line) (text-width (cadr line)))
  115.                fillchr
  116.                (cddr line)))
  117.     ((char? (cadr line))
  118.      (display (make-string (- (car line) hpos) fillchr))
  119.      (display-line (car line)
  120.                (cadr line)
  121.                (cddr line)))
  122.     (else (error "DISPLAY-LINE: problem in?" line))))
  123.  
  124. ;;; Glue 2 boxes together horizontally, with the RIGHTBOX moved
  125. ;;; POSINC to the right
  126.  
  127. (define (hglue-lines! leftbox posinc rightbox)
  128.   (cond ((null? rightbox) leftbox)
  129.     ((null? leftbox) '())
  130.     ((char? (car rightbox))
  131.      (cons (nconc (car leftbox) (list posinc (string (car rightbox))))
  132.            (hglue-lines! (cdr leftbox) posinc rightbox)))
  133.     ((< (top-edge leftbox) (top-edge rightbox))
  134.      (cons (car leftbox)
  135.            (hglue-lines! (cdr leftbox) posinc rightbox)))
  136.     (else                ;line up
  137.      (if (not (zero? posinc)) (shift-numbers! (cdar rightbox) posinc))
  138.      (cons (nconc (car leftbox) (cdar rightbox))
  139.            (hglue-lines! (cdr leftbox) posinc (cdr rightbox))))))
  140.  
  141. (define (hglue boxes hroom)
  142.   (let ((arights (list (cond ((null? (car boxes)) 0)
  143.                  ((char? (car (car boxes))) 1)
  144.                  (else (right-edge (car boxes))))))
  145.     (right -1) (top 0) (bottom 0))
  146.     (do ((boxes boxes (cdr boxes))
  147.      (rights
  148.       arights
  149.       (begin (set-cdr!
  150.           rights
  151.           (if (null? (cdr boxes)) '()
  152.               (list (cond ((null? (cadr boxes)) 0)
  153.                   ((char? (caadr boxes)) 1)
  154.                   (else (right-edge (cadr boxes)))))))
  155.          (cdr rights)))
  156.      (redge 0 (+ redge (car rights))))
  157.     ((or (null? boxes) (and (positive? right) (> redge hroom)))
  158.      (if (<= redge hroom) (set! right -2)))
  159.       (cond ((equal? (car boxes) '((0 0 break)))
  160.          (set! right redge))
  161.         ((char? (caar boxes)))
  162.         (else (set! bottom (max bottom (bottom-edge (car boxes))))
  163.           (set! top (min top (top-edge (car boxes)))))))
  164.     (do ((boxes boxes (cdr boxes))
  165.      (rights arights (cdr rights))
  166.      (redge 0 (+ redge (car rights)))
  167.      (leftbox
  168.       (do ((i (+ -1 bottom) (+ -1 i))
  169.            (ans (list (list bottom)) (cons (list i) ans)))
  170.           ((< i top) ans))
  171.       (cond
  172.        ((equal? (car boxes) '((0 0 break)))
  173.         (cond ((= (+ redge (car rights)) right)
  174.            (set! arights #f)
  175.            (vformat! '((0 #d0000) (2 #d1000))
  176.                  (list (make-pbox 200 (list leftbox))
  177.                    (make-pbox 200 (cdr boxes)))
  178.                  #f hroom))
  179.           (else leftbox)))
  180.        (else (hglue-lines! leftbox redge (car boxes))))))
  181.     ((or (not arights) (null? boxes)) leftbox))))
  182.  
  183. ;;; Routines to format BOX from TEMPLATEs.
  184.  
  185. ;;; HFORMAT returns a list of boxes which need to be HGLUEd together
  186. ;;; into a single box.
  187.  
  188. (define (hformat hbox args tps hroom)
  189.   (if (null? hbox) '()
  190.       (let ((item (car hbox)) (hr (- hroom (quotient hroom 20))))
  191.     (cond
  192.      ((number? item)
  193.       (let ((argnum (arg-pos item)))
  194.         (if (> (length args) argnum)
  195.         (let ((arg (list-ref args argnum)))
  196.           (if (<= (arg-bp item) (pbox-bp arg))
  197.               (nconc (pbox-lines arg)
  198.                  (hformat (cdr hbox) args tps hroom))
  199.               (nconc
  200.                (hformat
  201.             (template-hbox (cdr (assq 'template:parenthesis tps)))
  202.             (list '() arg) tps hroom)
  203.                (hformat (cdr hbox) args tps hroom))))
  204.         (hformat (cdr hbox) args tps hroom))))
  205.      ((pair? item)
  206.       (cons (vformat! item args tps hr)
  207.         (hformat (cdr hbox) args tps hroom)))
  208.      ((vector? item)
  209.       (let ((vt (vector-ref item 0))
  210.         (vl (cdr (vector->list item))))
  211.         (cond ((<= (length args) (arg-pos (find-if number? vl)))
  212.            (hformat (cdr hbox) args tps hroom))
  213.           ((eq? 'REST vt)
  214.            (nconc (hformat vl args tps hroom)
  215.               (hformat hbox (cdr args) tps (- hroom hr))))
  216.           ((eq? 'OPTIONAL vt)
  217.            (nconc (hformat vl args tps hroom)
  218.               (hformat (cdr hbox) args tps hroom)))
  219.           (else (error "HFORMAT: unknown format" item)))))
  220.      (else (cons (list (list 0 0 item))
  221.              (hformat (cdr hbox) args tps hroom)))))))
  222.  
  223. (define (vformat! vbox args tps hroom)
  224.   (if (char? (car vbox))
  225.       vbox
  226.       (let* ((boxes (map (lambda (hbox)
  227.                (hglue (hformat (cdr hbox) args tps hroom)
  228.                   hroom))
  229.              vbox))
  230.          (rights (map right-edge boxes))
  231.          (mostright (apply max rights)))
  232.     (for-each
  233.      (lambda (box right)
  234.        (for-each
  235.         (lambda (line)
  236.           (cond ((null? (cdr line)))
  237.             ((and (char? (caddr line)) (null? (cdddr line)))
  238.              ;;terminate rubber line.
  239.              (nconc line (list mostright #\ )))
  240.             (else        ;center justify line.
  241.              (let ((lst (cdr line))
  242.                (inc (quotient (- mostright right) 2)))
  243.                (set-car! lst (+ inc (car lst)))
  244.                (shift-numbers! (cddr lst) inc)))))
  245.         box))
  246.      boxes
  247.      rights)
  248.     (vrenumber! vbox boxes)
  249.     (apply nconc boxes))))
  250.  
  251. ;;; the trick here is to make line 0 of hbox 0 still be line 0.  Push
  252. ;;; everything else up or down to make that happen.
  253. ;;; Here, vbox is used only for its hbox numbers.
  254. (define (vrenumber! vbox boxes)
  255.   (cond ((null? vbox) 0)
  256.     ((negative? (caar vbox))
  257.      (let ((topinc (+ (- (caar vbox)
  258.                  (if (null? (cdr vbox)) 0 (caadr vbox)))
  259.               (- (vrenumber! (cdr vbox) (cdr boxes))
  260.                  (bottom-edge (car boxes))))))
  261.        (or (zero? topinc)
  262.            (for-each
  263.         (lambda (line)
  264.           (set-car! line (+ (car line) topinc)))
  265.         (car boxes))))
  266.      (top-edge (car boxes)))
  267.     (else
  268.      (or (zero? (caar vbox))
  269.          (for-each            ;space down if no hbox 0
  270.           (lambda (line)
  271.         (set-car! line (+ (car line) (caar vbox))))
  272.           (car boxes)))
  273.      (let ((topinc (bottom-edge (car boxes)))
  274.            (lastnum (caar vbox)))
  275.        (for-each
  276.         (lambda (hbox box)
  277.           (set! topinc (+ (- (car hbox) lastnum)
  278.                   (- topinc (top-edge box))))
  279.           (set! lastnum (car hbox))
  280.           (for-each
  281.            (lambda (line)
  282.          (set-car! line (+ (car line) topinc)))
  283.            box)
  284.           (set! topinc (bottom-edge box)))
  285.         (cdr vbox)
  286.         (cdr boxes)))
  287.      (top-edge (car boxes)))))
  288.  
  289. ;;; Driver for 2d output
  290.  
  291. (define (inprint exp grm)
  292.   (tprint exp (grammar-write-tab grm)))
  293.  
  294. (define (tprint exp tps)
  295.   (let* ((owidth (output-port-width (current-output-port)))
  296.      (box (hglue (pbox-lines (unparse exp tps owidth)) owidth)))
  297.     (display-box (top-edge box) box)))
  298.  
  299. (define (unparse exp tps hroom)
  300.   (cond ((symbol? exp)
  301.      (make-pbox 200 (list (list (list 0 0 (symbol->string exp))))))
  302.     ((number? exp)
  303.      (make-pbox 200 (list (list (list 0 0 (number->string exp))))))
  304.     ((list? exp)
  305.      (let* ((p (assq (car exp) tps)))
  306.        (unparse1 (if p (cdr p) (cdr (assq 'TEMPLATE:DEFAULT tps)))
  307.              exp tps hroom)))
  308.     ((not (vector? exp))
  309.      (slib:error "UNPARSE: not s-expression" exp))
  310.     ((zero? (vector-length exp))    ;this special case should be eliminated
  311.      (make-pbox 200 (list (list (list 0 0 "[]")))))
  312.     ((and (vector? (vector-ref exp 0))
  313.           (assq 'TEMPLATE:MATRIX tps)
  314.           (let ((len (vector-length (vector-ref exp 0))))
  315.         (every (lambda (r) (and (vector? r) (= (vector-length r) len)))
  316.                (cdr (vector->list exp)))))
  317.      (let ((hr (quotient hroom (vector-length exp)))
  318.            (template (cdr (assq 'TEMPLATE:MATRIX tps))))
  319.        (make-pbox
  320.         (template-bp template)
  321.         (hformat
  322.          (template-hbox template)
  323.          (map (lambda (obj)
  324.             (unparse1 (rubber-vbox (length obj)) obj tps hr))
  325.           ;transpose of exp
  326.           (apply map list (map vector->list
  327.                        (vector->list exp))))
  328.          tps hroom))))
  329.     (else (unparse1 (cdr (assq 'TEMPLATE:BUNCH tps))
  330.             (vector->list exp) tps hroom))))
  331.  
  332. (define (unparse1 template exp tps hroom)
  333.   (define hr (- hroom (quotient hroom 20)))
  334.   (make-pbox (template-bp template)
  335.          (hformat (template-hbox template)
  336.               (map (lambda (exp)
  337.                  (unparse exp tps hr))
  338.                exp)
  339.               tps hroom)))
  340.  
  341. (define (rubber-vbox len)
  342.   (make-template 200 (list (rubvbox (- 1 len) len))))
  343.  
  344. (define (rubvbox i len)
  345.   (if (>= i len) '()
  346.       (cons (list i (+ (* 1000 (quotient (+ i len) 2)) 10))
  347.         (rubvbox (+ i 2) len))))
  348.  
  349. ;;;; Test code
  350. ;;; To test, load this and stdgrm.scm.  Do (test2d tps:2d).
  351.  
  352. (define (test2d tps)
  353.   (for-each
  354.    (lambda (b) (tprint b tps) (newline))
  355.    '(
  356.      (+ (* 3 a b) (* 2 (^ a 2) b) c (* d e))
  357.      (sum (* (rapply a i) (^ x (- i 2))) i 0 inf)
  358.      (= %gamma (limit (sum (- (over 1 n) (log m)) n 1 m) m inf))
  359.      (^ (- (over 1 (^ (+ y x) 4)) (over 3 (^ (+ y x) 3))) 2)
  360.      (^ x (over (+ (^ a 2) 1) a))
  361.      (+ (- (over 2 (+ x 2)) (over 2 (+ x 1)))
  362.     (over 1 (^ (+ x 1) 2)))
  363.      (over (* (+ (^ x 2) (* 2 x) 1) (- y 1))
  364.        (* 36 (+ y 1)))
  365.      (+ (* (^ %e (f x)) ((over (^ d 2) (^ dx 2)) (f x)))
  366.     (* (^ %e (f x)) (^ ((over d dx) (f x)) 2)))
  367.      (+ (integrate (f x) x a b) x)
  368.      (limit (^ (f x) (g (+ x 1))) x 0 minus)
  369.      (+ (over y (^ (box x) 2)) x)
  370.      (over (prod (^ (+ (^ x i) 1) (/ 5 2)) i 1 inf)
  371.        (+ (^ x 2) 1))
  372.      (over 1 (+ 4 (over 1 (+ 3 (over 1 42)))))
  373.      (over (* (factorial m) n (factorial (- n 1))) m)
  374.      (- (* 16 (^ a 2))
  375.     (* 2 (u 0 1) (at ((over d dx) (u x y)) (= x 0) (= y 1))))
  376.      )))
  377.  
  378. (define (textest)
  379.   (for-each
  380.    (lambda (b)
  381.      (tprint b tps:2d) (newline)
  382.      (tprint b tps:tex) (newline))
  383.    '(
  384.      (over (+ (^ a 2) c (* b x)) (+ 2 z))
  385.      (+ (^ (+ a b) (/ 1 2)) (^ e (/ 1 2)))
  386.      (arctan (arctan a))
  387.      (over (arctan
  388.         (over (- (/ (* 2 (^ b (/ 1 4)) x) (^ a (/ 1 4)))
  389.              (sqrt 2))
  390.           (sqrt 2)))
  391.        (* (^ 2 (/ 3 2)) (^ a (/ 3 4)) (^ b (/ 1 4))))
  392.      (over a (+ b c)))))
  393.  
  394. (define (mtest tps)
  395.   (for-each
  396.    (lambda (b) (tprint b tps) (newline))
  397.    '(
  398.      #((= x1 (negate (over 1 (sqrt 5))))
  399.        (= x2 (negate (over 2 (sqrt 5)))))
  400.      #(#((over 1 a) 0) #((negate (over b a)) 1))
  401.      #(#((^ a 2) 0) #((+ (* a b) b) 1)))))
  402.